home *** CD-ROM | disk | FTP | other *** search
/ Eagles Nest BBS 4 / Eagles_Nest_Mac_Collection_Disc_4.TOAST / Database Management / FoxPro25#1 / FoxPro 2.5 Disk - 1 Setup.image / Genmenu.prg / Genmenu.bin
Text File  |  1993-12-04  |  58KB  |  1,934 lines
  1. *
  2. * GENMENU - Menu code generator.
  3. *
  4. * Copyright (c) 1990 - 1993 Microsoft Corp.
  5. * 1 Microsoft Way
  6. * Redmond, WA 98052
  7. *
  8. * Description:
  9. * This program generates menu code which was designed in the
  10. * FoxPro 2.5 MENU BUILDER.
  11. *
  12. * Notes:
  13. * In this program, for clarity/readability reasons, we use variable
  14. * names that are longer than 10 characters.  Note, however, that only
  15. * the first 10 characters are significant.
  16. *
  17. * Modification History:
  18. * December 13, 1990        JAC        Program Created
  19. *
  20. * Modifed for FoxPro 2.5 by WJK.
  21. *
  22. PARAMETER m.projdbf, m.recno
  23. PRIVATE ALL
  24. IF SET("TALK") = "ON"
  25.     SET TALK OFF
  26.     m.talkstate = "ON"
  27. ELSE
  28.     m.talkstate = "OFF"
  29. ENDIF
  30. m.escape = SET("ESCAPE")
  31. *SET ESCAPE OFF
  32.  
  33. m.trbetween = SET("TRBET")
  34. SET TRBET OFF
  35. m.comp = SET("COMPATIBLE")
  36. SET COMPATIBLE OFF
  37. mdevice = SET("DEVICE")
  38. SET DEVICE TO SCREEN
  39.  
  40. *
  41. * Declare Constants
  42. *
  43. #DEFINE c_esc    CHR(27)
  44. #DEFINE c_null    CHR(0)
  45. #DEFINE c_aliaslen 10
  46. *
  47. * Possible values of Objtype field in SCX database.
  48. *
  49. #DEFINE c_menu        1
  50. #DEFINE c_submenu    2
  51. #DEFINE c_item        3
  52.  
  53. *
  54. * Some of the values of Objcode field in SCX database.
  55. *
  56. #DEFINE    c_global    1
  57. #DEFINE c_proc        80
  58.  
  59. #DEFINE c_maxsnippets    25
  60. #DEFINE c_maxpads        25
  61. #DEFINE c_pjx20flds        33
  62. #DEFINE c_pjxflds        31
  63. #DEFINE c_mnxflds        23
  64. #DEFINE c_20mnxflds        22
  65.  
  66. #DEFINE c_authorlen        45
  67. #DEFINE c_complen        45
  68. #DEFINE c_addrlen        45
  69. #DEFINE c_citylen        20
  70. #DEFINE c_statlen        5
  71. #DEFINE c_ziplen        10
  72. #DEFINE c_countrylen 40
  73.  
  74. #DEFINE c_error_1        "Minor"
  75. #DEFINE c_error_2        "Serious"
  76. #DEFINE c_error_3        "Fatal"
  77.  
  78. IF _MAC
  79.    m.g_dlgface     =    "Geneva"
  80.    m.g_dlgsize     =    10.000
  81.    m.g_dlgstyle =        ""
  82. ELSE
  83.    m.g_dlgface     =    "MS Sans Serif"
  84.    m.g_dlgsize     =    8.000
  85.    m.g_dlgstyle =        "B"
  86. ENDIF
  87.  
  88. #DEFINE c_replace        0
  89. #DEFINE c_append        1
  90. #DEFINE c_before        2
  91. #DEFINE c_after            3
  92.  
  93. #DEFINE c_pathsep  "\"
  94.  
  95. *
  96. * Declare Variables
  97. *
  98. STORE "" TO m.cursor, m.consol, m.bell, m.onerror, ;
  99.     m.exact, m.print, m.fixed, m.delimiters, m.mpoint, m.mcollate,m.mmacdesk
  100. STORE 0 TO m.deci, m.memowidth
  101.  
  102. m.g_error      = .F.
  103. m.g_errlog     = ""
  104. m.g_homedir    = ""
  105. m.g_location   = 0
  106. m.g_menucolor  = 0
  107. m.g_menumark   = ""
  108. m.g_nohandle   = .T.
  109. m.g_nsnippets  = 0
  110. m.g_outfile    = ""
  111. m.g_padloca    = ""
  112. m.g_projalias  = ""
  113. m.g_projdbf    = m.projdbf
  114. m.g_projpath   = ""
  115. m.g_status     = 0
  116. m.g_snippcnt   = 0
  117. m.g_thermwidth = 0
  118. m.g_workarea   = 0
  119. m.g_graphic    = .F.            
  120. m.g_20mnx       = .F.            
  121.  
  122. m.g_devauthor  = PADR("Author's Name",45," ")
  123. m.g_devcompany = PADR("Company Name",45, " ")
  124. m.g_devaddress = PADR("Address",45," ")
  125. m.g_devcity    = PADR("City",20," ")
  126. m.g_devstate   = "  "
  127. m.g_devzip     = PADR("Zip",10," ")
  128. m.g_devctry    = PADR("Country",40," ")
  129.  
  130. m.g_boxstrg = ['ƒ','ƒ','≥','≥','⁄','ø','¿','Ÿ','ƒ','ƒ','≥','≥','⁄','ø','¿','Ÿ']
  131.  
  132. STORE "" TO m.g_corn1, m.g_corn2, m.g_corn3, m.g_corn4, m.g_corn5, ;
  133.     m.g_corn6, m.g_verti2
  134. STORE "*" TO  m.g_horiz, m.g_verti1
  135.  
  136. *
  137. * Array Declarations
  138. *
  139. * g_mnxfile [1] - Normalized path + name
  140. * g_mnxfile [2] - Basename
  141. * g_mnxfile [3] - Opened originally?
  142. * g_mnxfile [4] - Alias
  143. *
  144. DIMENSION g_mnxfile[4]
  145. g_mnxfile[1] = ""
  146. g_mnxfile[2] = ""
  147. g_mnxfile[3] = .F.
  148. g_mnxfile[4] = ""
  149.  
  150. *
  151. * g_pads - names of generated menu pads
  152. *
  153. DIMENSION g_pads(c_maxpads)
  154.  
  155. *
  156. * g_snippets [*,1] - generated snippet procedure name
  157. * g_snippets [*,2] - recno()
  158. *
  159.  
  160. DIMENSION g_snippets (c_maxsnippets,2)
  161. g_snippets = ""
  162.  
  163. IF AT("WINDOWS", UPPER(VERSION())) <> 0 OR ;
  164.         AT("MAC", UPPER(VERSION())) <> 0
  165.     m.g_graphic = .T.
  166. ELSE
  167.     m.g_graphic = .F.
  168. ENDIF
  169.  
  170. *
  171. * Main program
  172. *
  173. m.onerror = ON("ERROR")
  174. ON ERROR DO errorhandler WITH MESSAGE(), LINENO(), c_error_3
  175.  
  176. IF PARAMETERS()=2
  177.     DO setup
  178.     IF validparams()
  179.         ON ESCAPE DO eschandler
  180.         SET ESCAPE ON
  181.         DO refreshprefs
  182.         DO BUILD
  183.     ENDIF
  184.     DO cleanup
  185. ELSE
  186.     DO errorhandler WITH "Invalid number of parameters passed to"+;
  187.         " the generator",LINENO(),c_error_3
  188. ENDIF
  189. ON ERROR &onerror
  190.  
  191. RETURN m.g_status
  192.  
  193. **
  194. ** Setup, Cleanup, Validparams, and Refreshprefs of Main Program
  195. **
  196.  
  197. *
  198. * STARTUP - Create program's environment.
  199. *
  200. * Description:
  201. * Save the user's environment so that we can set it back when
  202. * we are done, then issue various SET commands. The only state
  203. * we cannot conveniently save is SET TALK, because storing the
  204. * state involves an assignment statement, and assignments
  205. * generate unwanted output if TALK is set ON.
  206. *
  207. * Side Effects:
  208. * Creates a temporary file which is deleted in the Cleanup
  209. * procedure executed at the end of MENUGEN.
  210. *
  211. PROCEDURE setup
  212.     CLEAR PROGRAM
  213.     CLEAR GETS
  214.     m.g_workarea = SELECT()
  215.     m.delimiters = SET('TEXTMERGE',1)
  216.     SET TEXTMERGE DELIMITERS TO
  217.     SET UDFPARMS TO VALUE
  218.     
  219.     m.bell = SET("BELL")
  220.     SET BELL OFF
  221.     m.consol = SET("CONSOLE")
  222.     SET CONSOLE OFF
  223.     m.cursor = SET("CURSOR")
  224.     SET CURSOR OFF
  225.     m.deci = SET("DECIMALS")
  226.     SET DECIMALS TO 0
  227.     mdevice = SET("DEVICE")
  228.     SET DEVICE TO SCREEN
  229.     m.memowidth = SET("MEMOWIDTH")
  230.     SET MEMOWIDTH TO 256
  231.     m.exact = SET("EXACT")
  232.     SET EXACT ON
  233.     m.print = SET("PRINT")
  234.     SET PRINT OFF
  235.     m.fixed = SET("FIXED")
  236.     SET FIXED ON
  237.     mpoint = SET("POINT")
  238.     SET POINT TO "."
  239.     mcollate = SET("COLLATE")
  240.     SET COLLATE TO "machine"
  241.      #if "MAC" $ UPPER(VERSION(1))
  242.         IF _MAC
  243.            m.mmacdesk = SET("MACDESKTOP")
  244.            SET MACDESKTOP ON
  245.        ENDIF
  246.      #endif
  247. *
  248. * CLEANUP - restore environment to pre-execution state.
  249. *
  250. * Description:
  251. * Close all databases opened in the course of the execution of MENUGEN.
  252. * Restore the environment to the pre-execution of MENUGEN.  Delete
  253. * the VIEW file since there is no further use for it.
  254. *
  255. * Side Effects:
  256. * Closes databases.
  257. * Deletes the temporary view file.
  258. *
  259. PROCEDURE cleanup
  260.     PRIVATE m.delilen, m.ldelimi, m.rdelimi
  261.     IF EMPTY(m.g_projalias)
  262.         RETURN
  263.     ENDIF
  264.     SELECT (m.g_projalias)
  265.     USE
  266.     IF NOT EMPTY(g_mnxfile[3])
  267.         IF USED(g_mnxfile[4])
  268.             SELECT (g_mnxfile[4])
  269.             USE
  270.         ENDIF
  271.     ENDIF
  272.     SELECT (m.g_workarea)
  273.     
  274.     m.delilen = LEN(m.delimiters)
  275.     m.ldelimi = SUBSTR(m.delimiters,1,;
  276.         IIF(MOD(m.delilen,2)=0,m.delilen/2,CEILING(m.delilen/2)))
  277.     m.rdelimi = SUBSTR(m.delimiters,;
  278.         IIF(MOD(m.delilen,2)=0,m.delilen/2+1,CEILING(m.delilen/2)+1))
  279.     SET TEXTMERGE DELIMITERS TO m.ldelimi, m.rdelimi
  280.     
  281.     IF m.bell = "ON"
  282.         SET BELL ON
  283.     ENDIF
  284.     IF m.cursor = "ON"
  285.         SET CURSOR ON
  286.     ELSE
  287.         SET CURSOR OFF
  288.     ENDIF
  289.     IF m.consol = "ON"
  290.         SET CONSOLE ON
  291.     ENDIF
  292.     IF m.escape = "ON"
  293.         SET ESCAPE ON
  294.     ELSE
  295.         SET ESCAPE OFF
  296.     ENDIF
  297.     IF m.print = "ON"
  298.         SET PRINT ON
  299.     ENDIF
  300.     IF m.exact = "OFF"
  301.         SET EXACT OFF
  302.     ENDIF
  303.     IF m.fixed = "OFF"
  304.         SET FIXED OFF
  305.     ENDIF
  306.     SET DECIMALS TO m.deci
  307.     SET MEMOWIDTH TO m.memowidth
  308.     SET DEVICE TO &mdevice
  309.     IF m.trbetween = "ON"
  310.         SET TRBET ON
  311.     ENDIF
  312.     IF m.comp = "ON"
  313.         SET COMPATIBLE ON
  314.     ENDIF
  315.     IF m.talkstate = "ON"
  316.         SET TALK ON
  317.     ENDIF
  318.     SET POINT TO "&mpoint"
  319.     SET COLLATE TO "&mcollate"
  320.     SET MESSAGE TO
  321.     #if "MAC" $ UPPER(VERSION(1))
  322.         IF _MAC
  323.           SET MACDESKTOP &mmacdesk
  324.         ENDIF
  325.     #endif
  326.     
  327.     ON ERROR &onerror
  328.    
  329.     
  330. *
  331. * VALIDPARAMS - Validate generator parameters.
  332. *
  333. * Description:
  334. * Attempt to open the project database.  If error encountered then
  335. * on error routine takes over and issues 'CANCEL'.  The output file
  336. * cannot be erased, name not known.
  337. *
  338. FUNCTION validparams
  339.     SELECT 0
  340.     m.g_projalias = IIF(USED("projdbf"),"P"+;
  341.         SUBSTR(LOWER(SYS(3)),2,8),"projdbf")
  342.     USE (m.projdbf) ALIAS (m.g_projalias)
  343.     IF versnum() > "2.5"
  344.        SET NOCPTRANS TO devinfo, arranged, symbols, object
  345.     ENDIF
  346.    
  347.     m.g_errlog = stripext(m.projdbf)
  348.     m.g_projpath = SUBSTR(m.projdbf,1,RAT("\",m.projdbf))
  349.     
  350.     IF FCOUNT() <> c_pjxflds
  351.         DO errorhandler WITH "Generator out of date.",;
  352.             LINENO(), c_error_2
  353.         RETURN .F.
  354.     ENDIF
  355.     
  356.     GOTO RECORD m.recno
  357.     
  358.     m.g_outfile = ALLTRIM(SUBSTR(outfile,1,AT(c_null,outfile)-1))
  359.     m.g_outfile = FULLPATH(m.g_outfile, m.g_projpath)
  360.     IF _MAC AND RIGHT(m.g_outfile,1) = ":"
  361.        m.g_outfile = m.g_outfile + justfname(SUBSTR(outfile,1,AT(c_null,outfile)-1))
  362.     ENDIF
  363.     g_mnxfile[1] = FULLPATH(ALLTRIM(name), m.g_projpath)
  364.     IF _MAC AND RIGHT(g_mnxfile[1],1) = ":"
  365.        g_mnxfile[1] = g_mnxfile[1] + justfname(name)
  366.     ENDIF
  367.     g_mnxfile[2] = basename(g_mnxfile[1])
  368.     
  369. *
  370. * REFRESHPREFS - Refresh comment style and developer preferences.
  371. *
  372. * Description:
  373. * Get the newest preferences for documentation style and developer
  374. * data from the project database.
  375. *
  376. PROCEDURE refreshprefs
  377.     PRIVATE m.start, m.savrecno
  378.     m.savrecno = RECNO()
  379.     LOCATE FOR TYPE = "H"
  380.     IF NOT FOUND ()
  381.         DO errorhandler WITH "Missing header record in "+m.g_projdbf,;
  382.             LINENO(), c_error_2
  383.         GOTO RECORD m.savrecno
  384.         RETURN
  385.     ENDIF
  386.     
  387.     m.g_homedir = ALLTRIM(SUBSTR(homedir,1,AT(c_null,homedir)-1))
  388.     
  389.     m.start = 1
  390.     m.g_devauthor = subdevinfo(m.start,c_authorlen,m.g_devauthor)
  391.     
  392.     m.start = m.start + c_authorlen + 1
  393.     m.g_devcompany = subdevinfo(m.start,c_complen,m.g_devcompany)
  394.     
  395.     m.start = m.start + c_complen + 1
  396.     m.g_devaddress = subdevinfo(m.start,c_addrlen,m.g_devaddress)
  397.     
  398.     m.start = m.start + c_addrlen + 1
  399.     m.g_devcity = subdevinfo(m.start,c_citylen,m.g_devcity)
  400.     
  401.     m.start = m.start + c_citylen + 1
  402.     m.g_devstate = subdevinfo(m.start,c_statlen,m.g_devstate)
  403.     
  404.     m.start = m.start + c_statlen + 1
  405.     m.g_devzip = subdevinfo(m.start,c_ziplen,m.g_devzip)
  406.  
  407.     m.start = m.start + c_ziplen + 1
  408.     m.g_devctry = subdevinfo(m.start,c_countrylen,m.g_devctry)
  409.     
  410.     IF cmntstyle = 0
  411.         m.g_corn1 = "÷"
  412.         m.g_corn2 = "∑"
  413.         m.g_corn3 = "”"
  414.         m.g_corn4 = "Ω"
  415.         m.g_corn5 = "«"
  416.         m.g_corn6    = "∂"
  417.         m.g_horiz = "ƒ"
  418.         m.g_verti1 = "∫"
  419.         m.g_verti2 = "∫"
  420.     ENDIF
  421.     GOTO RECORD m.savrecno
  422.     
  423. *
  424. * SUBDEVINFO - Substring the DEVINFO memo filed.
  425. *
  426. FUNCTION subdevinfo
  427.     PARAMETER m.start, m.stop, m.default
  428.     PRIVATE m.string
  429.     m.string = SUBSTR(devinfo, m.start, m.stop+1)
  430.     m.string = SUBSTR(m.string, 1, AT(c_null,m.string)-1)
  431.     RETURN IIF(EMPTY(m.string), m.default, m.string)
  432.     
  433. **
  434. ** Menu Code Generator's Main Module.
  435. **
  436.  
  437. *
  438. * BUILD - Generate code for a menu.
  439. *
  440. * Description:
  441. * Call BUILDENABLE to open .MNX database specified by the user.
  442. * If the above is successfully accomplished, then proceed to generate
  443. * the menu code.  After the menu code is generated, call BUILDDISABLE
  444. * to disable code generation between SET TEXTMERGE ON and
  445. * SET TEXTMERGE OFF.
  446. *
  447. PROCEDURE BUILD
  448.     IF NOT buildenable()
  449.         RETURN
  450.     ENDIF
  451.     DO acttherm WITH "Generating Menu Code..."
  452.     DO updtherm WITH 10
  453.     
  454.     DO HEADER
  455.     DO gensetupcleanup WITH "setup"
  456.     DO definemenu
  457.     DO definepopups
  458.     DO updtherm WITH 75
  459.     DO globaldefaults
  460.     DO updtherm WITH 95
  461.     DO gensetupcleanup WITH "cleanup"
  462.     DO genprocedures
  463.     
  464.     IF m.g_graphic
  465.         SET MESSAGE TO 'Generation Complete'
  466.     ENDIF
  467.     DO builddisable
  468.     DO updtherm WITH 100
  469.     DO deactthermo
  470.     
  471. *
  472. * BUILDENABLE - Enable code generation.
  473. *
  474. * Description:
  475. * Call opendb to open .MNX database.
  476. * Call openfile to open file to hold the generated program.
  477. * If error(s) encountered in opendb or openfile then don't do
  478. * anything and exit, otherwise enable code generation with the
  479. * SET TEXTMERGE ON command.
  480. *
  481. * Returns:
  482. * .T. on success; .F. on failure
  483. *
  484. FUNCTION buildenable
  485.     PRIVATE m.stat
  486.     m.stat = opendb(g_mnxfile[1]) AND openfile()
  487.     IF m.stat
  488.         SET TEXTMERGE ON
  489.     ENDIF
  490.     RETURN m.stat
  491.     
  492. *
  493. * BUILDDISABLE - Disable code generation.
  494. *
  495. * Description:
  496. * Issue the command SET TEXTMERGE OFF.
  497. * Close the generated menu code output file.
  498. * If anything goes wrong display appropriate message to the user.
  499. *
  500. PROCEDURE builddisable
  501.     SET ESCAPE OFF
  502.     ON ESCAPE
  503.     SET TEXTMERGE OFF
  504.     IF NOT FCLOSE(_TEXT)
  505.         DO errorhandler WITH "Unable to Close the Application File",;
  506.             LINENO(), c_error_2
  507.     ENDIF
  508.     
  509. *
  510. * OPENDB - Prepare database for processing.
  511. *
  512. * Description:
  513. * Attempt to USE a database.  If attempt fails and error is reported
  514. * call ERRORHANDLER routine to display a friendly message.  Return
  515. * with a status of .F..  If attempt succeeds, return with status of .T.
  516. *
  517. * Returns:
  518. * .T. on success; .F. on failure
  519. *
  520. FUNCTION opendb
  521.     PARAMETER m.dbname
  522.     PRIVATE m.dbalias
  523.     ON ERROR DO errorhandler WITH MESSAGE(), LINENO(), c_error_2
  524.     
  525.     m.dbalias = LEFT(basename(m.dbname),c_aliaslen)
  526.     IF USED (m.dbalias)
  527.         SELECT (m.dbalias)
  528.         IF RAT(".MNX",DBF())<>0
  529.             g_mnxfile[3] = .F.
  530.             g_mnxfile[4] = m.dbalias
  531.         ELSE
  532.             g_mnxfile[4] = "M"+SUBSTR(LOWER(SYS(3)),2,8)
  533.             SELECT 0
  534.             USE (m.dbname) AGAIN ALIAS (g_mnxfile[4])
  535.             g_mnxfile[3] = .T.
  536.         ENDIF
  537.     ELSE
  538.         IF illegalname(m.dbalias)
  539.             g_mnxfile[4] = "M"+SUBSTR(LOWER(SYS(3)),2,8)
  540.         ELSE
  541.             g_mnxfile[4] = m.dbalias
  542.         ENDIF
  543.         SELECT 0
  544.         USE (m.dbname) AGAIN ALIAS (g_mnxfile[4])
  545.         g_mnxfile[3] = .T.
  546.     ENDIF
  547.     
  548.     IF FCOUNT() <> c_mnxflds
  549.         IF FCOUNT() = c_20mnxflds
  550.             m.g_20mnx = .T.
  551.         ELSE
  552.             DO errorhandler WITH "Menu "+m.dbalias+" is invalid",LINENO(),;
  553.                 c_error_2
  554.             RETURN .F.
  555.         ENDIF
  556.     ELSE
  557.         m.g_20mnx = .F.
  558.     ENDIF
  559.     
  560.     ON ERROR DO errorhandler WITH MESSAGE(), LINENO(), c_error_3
  561.     IF m.g_error = .T.
  562.         RETURN .F.
  563.     ENDIF
  564.     
  565. *
  566. * ILLEGALNAME - Check if default alias will be used when this
  567. *               database is USEd. (i.e., 1st letter is not A-Z,
  568. *                a-z or '_', or any one of ramaining letters is not
  569. *                alphanumeric.)
  570. *
  571. FUNCTION illegalname
  572.     PARAMETER m.menuname
  573.     PRIVATE m.start, m.aschar, m.length
  574.     m.length = LEN(m.menuname)
  575.     m.start  = 0
  576.     IF m.length = 1
  577.         *
  578.         * If length 1, then check if default alias can be used,
  579.         * i.e., name is different than A-J and a-j.
  580.         *
  581.         m.aschar = ASC(m.menuname)
  582.         IF (m.aschar >= 65 AND m.aschar <= 74) OR ;
  583.                 (m.aschar >= 97 AND m.aschar <= 106)
  584.             RETURN .T.
  585.         ENDIF
  586.     ENDIF
  587.     DO WHILE m.start < m.length
  588.         m.start  = m.start + 1
  589.         m.aschar = ASC(SUBSTR(m.menuname, m.start, 1))
  590.         IF m.start<>1 AND (m.aschar >= 48 AND m.aschar <= 57)
  591.             LOOP
  592.         ENDIF
  593.         IF NOT ((m.aschar >= 65 AND m.aschar <= 90) OR ;
  594.                 (m.aschar >= 97 AND m.aschar <= 122) OR m.aschar = 95)
  595.             RETURN .T.
  596.         ENDIF
  597.     ENDDO
  598.     RETURN .F.
  599.         
  600. *
  601. * OPENFILE - Create and open the application output file.
  602. *
  603. * Description:
  604. * Create a file that will hold the generated menu code.
  605. * Open the newly created file.  If error(s) encountered
  606. * at any time issue an error message and return .F.
  607. *
  608. * Returns:
  609. * .T. on success; .F. on failure
  610. *
  611. FUNCTION openfile
  612.     PRIVATE m.msg
  613.     _TEXT = FCREATE(m.g_outfile)
  614.     IF (_TEXT = -1)
  615.         m.msg = "Cannot open file "+m.g_outfile
  616.         DO errorhandler WITH m.msg, LINENO(), c_error_3
  617.         m.g_nohandle = .T.
  618.         RETURN .F.
  619.     ENDIF
  620.     m.g_nohandle = .F.
  621.     
  622. *
  623. * DEFINEMENU - Define main menu and its pads.
  624. *
  625. * Description:
  626. * Issue DEFINE MENU ... command.
  627. * Call a procedure to define all menu pads.
  628. * Call a procedure to generate ON PAD statements when appropriate.
  629. *
  630. PROCEDURE definemenu
  631.     
  632.     IF m.g_graphic
  633.         SET MESSAGE TO 'Generating menu definitions...'
  634.     ENDIF
  635.     DO commentblock WITH "menu"
  636.     SELECT (g_mnxfile[4])
  637.     LOCATE FOR objtype = c_menu
  638.     m.g_location = location
  639.     m.g_padloca  = ALLTRIM(name)
  640.     
  641.     LOCATE FOR objtype = c_submenu AND objcode = c_global
  642.     
  643.     m.g_menucolor = SCHEME
  644.     m.g_menumark  = MARK
  645.     IF m.g_location = c_replace
  646.         \SET SYSMENU TO
  647.         \
  648.     ENDIF
  649.     \SET SYSMENU AUTOMATIC
  650.     \
  651.     
  652.     DO updtherm WITH 25
  653.     DO defmenupads
  654.     DO updtherm WITH 35
  655.     DO defonpad
  656.     \
  657.     DO updtherm WITH 45
  658.     
  659. *
  660. * DEFMENUPADS - Define all pads for the menu bar.
  661. *
  662. * Description:
  663. * Scan the menu database for all objects of the type item which
  664. * have the levelname=_MSYSMENU.
  665. * For each such item, generate a statement DEFINE PAD... where
  666. * the name of the pad is the contents of NAME field or (if Name
  667. * field is empty) an automatically generated name.
  668. * Call procedures addkey, addskipfor, and mark to generate
  669. * KEY, SKIPFOR, or MARK clauses when appropriate.
  670. *
  671. PROCEDURE defmenupads
  672.     PRIVATE m.padname, m.prompt
  673.     SCAN FOR objtype=c_item AND UPPER(levelname)="_MSYSMENU"
  674.         IF NOT EMPTY(ALLTRIM(name))
  675.             g_pads[VAL(Itemnum)] = name
  676.         ELSE
  677.             g_pads[VAL(Itemnum)] = LOWER(SYS(2015))
  678.         ENDIF
  679.         \DEFINE PAD <<g_pads[VAL(Itemnum)]>> OF _MSYSMENU
  680.         
  681.         IF MOD(VAL(itemnum),25)=0
  682.             DIMENSION g_pads[VAL(Itemnum)+25]
  683.         ENDIF
  684.         m.prompt = SUBSTR(PROMPT,1,LEN(PROMPT))
  685.         \\ PROMPT "<<m.prompt>>"
  686.         \\ COLOR SCHEME <<m.g_menucolor>>
  687.         
  688.         IF m.g_menumark<>c_null AND m.g_menumark<>""
  689.             \\ ;
  690.             \    MARK "<<m.g_menumark>>"
  691.         ENDIF
  692.         
  693.         DO CASE
  694.             CASE m.g_location = c_before
  695.                 \\ ;
  696.                 \    BEFORE <<m.g_padloca>>
  697.             CASE m.g_location = c_after
  698.                 \\ ;
  699.                 \    AFTER
  700.                 IF VAL(itemnum) = 1
  701.                     \\ <<m.g_padloca>>
  702.                 ELSE
  703.                     \\ <<g_pads[VAL(Itemnum)-1]>>
  704.                 ENDIF
  705.         ENDCASE
  706.         
  707.         DO addkey
  708.         DO addskipfor
  709.         DO addmessage
  710.         
  711.     ENDSCAN
  712.     
  713. *
  714. * DEFONPAD - Generate ON PAD... statements.
  715. *
  716. * Description:
  717. * Generate ON PAD statements for each pad off of the main menu which
  718. * has a submenu associated with it.
  719. * For pads which have no submenus, but there is a command associated
  720. * with them, issue ON SELECTION PAD... statements.  If the code
  721. * associated with a pad is a snippet, then issue a call to the
  722. * generated procedure and place the snippet code in it.
  723. *
  724. PROCEDURE defonpad
  725.     PRIVATE m.padname
  726.     SCAN FOR objtype=c_item AND UPPER(levelname)="_MSYSMENU"
  727.          IF NOT EMPTY(ALLTRIM(name))
  728.                m.padname = name
  729.          ELSE
  730.                m.padname = g_pads[VAL(Itemnum)]
  731.          ENDIF
  732.          m.therec = RECNO()
  733.          SKIP
  734.          IF objtype=c_submenu AND numitems<>0
  735.                \ON PAD <<m.padname>> OF _MSYSMENU
  736.                \\ ACTIVATE POPUP <<LOWER(Name)>>
  737.                GOTO m.therec
  738.          ELSE
  739.                GOTO m.therec
  740.                DO onselection WITH "pad", m.padname, '_MSYSMENU'
  741.          ENDIF
  742.     ENDSCAN
  743.     
  744. *
  745. * DEFINEPOPUPS - Define popups and their bars.
  746. *
  747. * Description:
  748. * Scan the Menu database to find all objecttypes = submenu.
  749. * They all correspond to popups.  For each such object found, issue
  750. * command DEFINE POPUP....  Add MARK, KEY, and SKIP FOR clauses
  751. * if appropriate by calling procedures to handle these tasks.  Call
  752. * procedure Defbars to define all bars of each popup.
  753. *
  754. PROCEDURE definepopups
  755.     PRIVATE m.savrecno, m.popname, m.sch
  756.     IF m.g_graphic
  757.         SET MESSAGE TO 'Generating popup definitions...'
  758.     ENDIF
  759.     SCAN FOR objtype=c_submenu AND UPPER(levelname)<>"_MSYSMENU" ;
  760.             AND numitems <> 0
  761.         
  762.         m.savrecno = RECNO()
  763.         m.popname  = ALLTRIM(LOWER(levelname))
  764.         m.sch      = SCHEME
  765.         
  766.         \DEFINE POPUP <<LOWER(Name)>> MARGIN RELATIVE SHADOW
  767.         \\ COLOR SCHEME <<m.sch>>
  768.         
  769.         DO addmark
  770.         DO addkey
  771.         DO defbars WITH m.popname, numitems
  772.         DO defonbar WITH m.popname
  773.         \
  774.         GOTO RECORD m.savrecno
  775.     ENDSCAN
  776.     
  777. *
  778. * DEFBARS - Define bars for each popup.
  779. *
  780. * Description:
  781. * Scan the menu database for all objects of the type item whose
  782. * name equals to the current popup name.
  783. * For each such item, generate a statement DEFINE BAR....
  784. * Call procedures addkey, addskipfor, and addmark to generate
  785. * KEY, SKIPFOR, or MARK clauses when appropriate.
  786. *
  787. PROCEDURE defbars
  788.     PARAMETER m.popname, m.howmany, m.name
  789.     PRIVATE m.itemno, m.prompt
  790.     SCAN FOR objtype=c_item AND LOWER(levelname)=m.popname
  791.         m.itemno = ALLTRIM(itemnum)
  792.         
  793.         IF NOT EMPTY(ALLTRIM(name))
  794.             m.name = name
  795.             \DEFINE BAR <<m.name>> OF <<LOWER(m.popname)>>
  796.         ELSE
  797.             \DEFINE BAR <<m.itemno>> OF <<LOWER(m.popname)>>
  798.         ENDIF
  799.         m.prompt = SUBSTR(PROMPT, 1,LEN(PROMPT))
  800.         \\ PROMPT "<<m.prompt>>"
  801.         
  802.         DO addmark
  803.         DO addkey
  804.         DO addskipfor
  805.         DO addmessage
  806.         
  807.         IF VAL(m.itemno)=m.howmany
  808.             RETURN
  809.         ENDIF
  810.     ENDSCAN
  811.     
  812. *
  813. * DEFONBAR - Generate ON BAR... statements.
  814. *
  815. * Description:
  816. * Generate ON BAR statements for each popup.
  817. * For bars which have no submenus, but there is a command associated
  818. * with them, issue ON SELECTION BAR... statements.  If a snippet is
  819. * associated with the code then generate a call statement to the
  820. * generated procedure containing the snippet code.
  821. *
  822. PROCEDURE defonbar
  823.     PARAMETER m.popname
  824.     PRIVATE m.itemno
  825.     SCAN FOR objtype=c_item AND LOWER(levelname)=m.popname
  826.         IF EMPTY(ALLTRIM(name))
  827.             m.itemno = ALLTRIM(itemnum)
  828.         ELSE
  829.             m.itemno = name
  830.         ENDIF
  831.         SKIP
  832.         IF objtype=c_submenu AND numitems<>0
  833.             \ON BAR <<m.itemno>> OF <<LOWER(m.popname)>>
  834.             \\ ACTIVATE POPUP <<LOWER(Name)>>
  835.             SKIP -1
  836.         ELSE
  837.             SKIP -1
  838.             DO onselection WITH "BAR", m.itemno, m.popname
  839.         ENDIF
  840.     ENDSCAN
  841.     
  842. *
  843. * GLOBALDEFAULTS - Generate global default statements
  844. *
  845. * Description:
  846. * Search the menu database for information needed to generate any of
  847. * the following commands:
  848. * ON SELECTION MENU <name> DO <action>
  849. * ON SELECTION POPUP ALL DO <action>
  850. * ON SELECTION POPUP <name> DO <action>
  851. * It is possible that none of the above mentioned statements will be
  852. * generated.  It is also possible that the action is a snippet of
  853. * code and a call to the generated procedure containing the snippet
  854. * will be generated.
  855. *
  856. * First try to generate ON SELECTION MENU...
  857. * Then try to generate ON POPUP ALL...
  858. * Lastly, try to generate ON SELECTION POPUP...
  859. *
  860. PROCEDURE globaldefaults
  861.     LOCATE FOR objtype = c_menu
  862.     m.mrk = MARK
  863.     IF FOUND() AND MARK <> ""
  864.         IF MARK = c_null
  865.             \SET MARK OF MENU _MSYSMENU TO " "
  866.         ELSE
  867.             \SET MARK OF MENU _MSYSMENU TO "<<Mark>>"
  868.         ENDIF
  869.     ENDIF
  870.     IF FOUND() AND NOT EMPTY(PROCEDURE)
  871.         \ON SELECTION MENU _MSYSMENU
  872.         DO genproccall
  873.     ENDIF
  874.     LOCATE FOR objtype = c_submenu AND objcode = c_global
  875.     IF FOUND() AND NOT EMPTY(PROCEDURE)
  876.         \ON SELECTION POPUP ALL
  877.         DO genproccall
  878.     ENDIF
  879.     SCAN FOR (objtype=c_submenu AND UPPER(levelname)<>"_MSYSMENU";
  880.             AND NOT EMPTY(PROCEDURE))
  881.         \ON SELECTION POPUP <<ALLTRIM(LOWER(Levelname))>>
  882.         DO genproccall
  883.     ENDSCAN
  884.     
  885. **
  886. ** Subroutines for processing menu clause options.
  887. **
  888.  
  889. *
  890. * ADDMARK - Generate a MARK clause whenever appropriate.
  891. *
  892. * Description:
  893. * Add a MARK clause to the current PAD or BAR definition.
  894. * If a field named Mark is not empty, then add the continuation
  895. * character, ";", to the previous line, and then add the MARK... clause.
  896. *
  897. PROCEDURE addmark
  898.     IF MARK<>c_null AND MARK<>""
  899.         \\ ;
  900.             \    MARK "<<Mark>>"
  901.     ENDIF
  902.     
  903. *
  904. * ADDKEY - Generate KEY... clause whenever appropriate.
  905. *
  906. * Description:
  907. * Add a KEY clause to the current PAD or BAR definition.
  908. * If a field named Keyname is not empty, then add the continuation
  909. * character, ";", to the previous line, and then add the KEY... clause.
  910. *
  911. PROCEDURE addkey
  912.     IF NOT EMPTY(keyname)
  913.         \\ ;
  914.         \    KEY <<Keyname>>, "<<Keylabel>>"
  915.     ENDIF
  916.     
  917. *
  918. * ADDSKIPFOR - Generate SKIP FOR... clause whenever appropriate.
  919. *
  920. * Description:
  921. * Add a ADDSKIPFOR clause to the current PAD or BAR definition.
  922. * If a field named Addskipfor is not empty, then add the continuation
  923. * character, ";", to the previous line, and then add the SKIP FOR...
  924. * clause.
  925. *
  926. PROCEDURE addskipfor
  927.     PRIVATE m.skip
  928.     m.skip = skipfor
  929.     IF NOT EMPTY(skipfor)
  930.         \\ ;
  931.         \    SKIP FOR <<m.skip>>
  932.     ENDIF
  933.     
  934. *
  935. * ADDMESSAGE - Generate MESSAGE clause whenever appropriate.
  936. *
  937. * Description:
  938. * Add a MESSAGE clause to the current PAD or BAR definition.
  939. * If a field named MESSAGE is not empty and it is not a 2.0 menu,
  940. * then add the continuation character, ";", to the previous line,
  941. * and then add the MESSAGE clause.
  942. *
  943. PROCEDURE addmessage
  944.     
  945.     IF !m.g_20mnx AND NOT EMPTY(MESSAGE)
  946.         \\ ;
  947.         \    MESSAGE <<Message>>
  948.     ENDIF
  949.         
  950. *
  951. * HEADER - Generate generated program's header.
  952. *
  953. * Description:
  954. * As a part of the automatically generated program's header generate
  955. * program name, name of the author of the program, copyright notice,
  956. * company name and address, and the word 'Description:' which will be
  957. * followed with a short description of the generated code.
  958. *
  959. PROCEDURE HEADER
  960.     \\*       <<m.g_corn1>><<REPLICATE(m.g_horiz,57)>><<m.g_corn2>>
  961.     \*       <<m.g_verti1>><<REPLICATE(" ",57)>><<m.g_verti2>>
  962.     \*       <<m.g_verti1>> <<DATE()>>
  963.     \\<<PADC(UPPER(ALLTRIM(strippath(m.g_outfile))),IIF(SET("CENTURY")="ON",35,37))," ")>>
  964.     \\ <<TIME()>>  <<m.g_verti2>>
  965.     \*       <<m.g_verti1>><<REPLICATE(" ",57)>><<m.g_verti2>>
  966.     \*       <<m.g_corn5>><<REPLICATE(m.g_horiz,57)>><<m.g_corn6>>
  967.     \*       <<m.g_verti1>><<REPLICATE(" ",57)>><<m.g_verti2>>
  968.     \*       <<m.g_verti1>> <<m.g_devauthor>>
  969.     \\<<REPLICATE(" ",56-LEN(m.g_devauthor))>><<m.g_verti2>>
  970.     \*       <<m.g_verti1>><<REPLICATE(" ",57)>><<m.g_verti2>>
  971.     \*       <<m.g_verti1>>
  972.     \\ Copyright (c) <<YEAR(DATE())>>
  973.     IF LEN(ALLTRIM(m.g_devcompany)) <= 36
  974.         \\ <<ALLTRIM(m.g_devcompany)>>
  975.         \\<<REPLICATE(" ",37-LEN(ALLTRIM(m.g_devcompany)))>>
  976.         \\<<m.g_verti2>>
  977.     ELSE
  978.         \\ <<REPLICATE(" ",37)>><<m.g_verti2>>
  979.         \*       <<m.g_verti1>> <<m.g_devcompany>>
  980.         \\<<REPLICATE(" ",56-LEN(m.g_devcompany))>><<m.g_verti2>>
  981.     ENDIF
  982.     
  983.     \*       <<m.g_verti1>> <<m.g_devaddress>>
  984.     \\<<REPLICATE(" ",56-LEN(m.g_devaddress))>><<m.g_verti2>>
  985.     
  986.     \*       <<m.g_verti1>> <<ALLTRIM(m.g_devcity)>>, <<m.g_devstate>>
  987.     \\  <<ALLTRIM(m.g_devzip)>>
  988.     \\<<REPLICATE(" ",50-(LEN(ALLTRIM(m.g_devcity)+ALLTRIM(m.g_devzip))))>>
  989.     \\<<m.g_verti2>>
  990.     
  991.     IF !INLIST(ALLTRIM(UPPER(m.g_devctry)),"USA","COUNTRY") AND !EMPTY(m.g_devctry)
  992.        \*       <<m.g_verti1>> <<ALLTRIM(m.g_devctry)>>
  993.        \\<<REPLICATE(" ",50-(LEN(ALLTRIM(m.g_devctry))))>>
  994.        \\<<m.g_verti2>>
  995.     ENDIF
  996.         
  997.     \*       <<m.g_verti1>><<REPLICATE(" ",57)>><<m.g_verti2>>
  998.     \*       <<m.g_verti1>> Description:
  999.     \\                                            <<m.g_verti2>>
  1000.     \*       <<m.g_verti1>>
  1001.     \\ This program was automatically generated by GENMENU.
  1002.     \\    <<m.g_verti2>>
  1003.     \*       <<m.g_verti1>><<REPLICATE(" ",57)>><<m.g_verti2>>
  1004.     \*       <<m.g_corn3>><<REPLICATE(m.g_horiz,57)>><<m.g_corn4>>
  1005.     \
  1006.     
  1007. *
  1008. * GENFUNCHEADER - Generate Comment for Function/Procedure.
  1009. *
  1010. PROCEDURE genfuncheader
  1011.     PARAMETER m.procname
  1012.     PRIVATE m.place, m.prompt
  1013.     m.g_snippcnt = m.g_snippcnt + 1
  1014.     DO CASE
  1015.         CASE objtype = c_menu
  1016.             m.place = "ON SELECTION MENU _MSYSMENU"
  1017.         CASE objtype = c_submenu AND objcode = c_global
  1018.             m.place = "ON SELECTION POPUP ALL"
  1019.         CASE objtype = c_submenu AND objcode <> c_global
  1020.             m.place = "ON SELECTION POPUP "+LOWER(ALLTRIM(name))
  1021.         CASE objtype = c_item AND UPPER(levelname) = "_MSYSMENU"
  1022.             m.place = "ON SELECTION PAD "
  1023.         CASE objtype = c_item AND UPPER(levelname) <> "_MSYSMENU"
  1024.             m.place = "ON SELECTION BAR "+ALLTRIM(itemnum)+;
  1025.                 +" OF POPUP "+LOWER(ALLTRIM(levelname))
  1026.         OTHERWISE
  1027.             m.place = ""
  1028.     ENDCASE
  1029.     \
  1030.     \*       <<m.g_corn1>><<REPLICATE(m.g_horiz,57)>><<m.g_corn2>>
  1031.     \*       <<m.g_verti1>><<REPLICATE(" ",57)>><<m.g_verti2>>
  1032.     \*       <<m.g_verti1>> <<UPPER(PADR(m.procname,10))>>  <<m.place>>
  1033.     \\<<REPLICATE(" ",44-LEN(m.place))>><<m.g_verti2>>
  1034.     \*       <<m.g_verti1>><<REPLICATE(" ",57)>><<m.g_verti2>>
  1035.     \*       <<m.g_verti1>> Procedure Origin:
  1036.     \\<<REPLICATE(" ",39)>><<m.g_verti2>>
  1037.     \*       <<m.g_verti1>><<REPLICATE(" ",57)>><<m.g_verti2>>
  1038.     \*       <<m.g_verti1>> From Menu:
  1039.     \\  <<ALLTRIM(strippath(m.g_outfile))>>
  1040.     \\,            Record:  <<STR(RECNO(),3)>>
  1041.     \\<<REPLICATE(" ",22-LEN(ALLTRIM(strippath(m.g_outfile))+STR(RECNO(),3))))>>
  1042.     \\<<m.g_verti2>>
  1043.     \*       <<m.g_verti1>> Called By:  <<m.place>>
  1044.     \\<<REPLICATE(" ",44-LEN(m.place))>><<m.g_verti2>>
  1045.     IF NOT EMPTY(PROMPT)
  1046.         m.prompt = removemeta()
  1047.         \*       <<m.g_verti1>> Prompt:     <<ALLTRIM(m.prompt)>>
  1048.         \\<<REPLICATE(" ",44-LEN(ALLTRIM(m.prompt)))>><<m.g_verti2>>
  1049.     ENDIF
  1050.     \*       <<m.g_verti1>> Snippet:
  1051.     \\    <<ALLTRIM(STR(m.g_snippcnt,2))>>
  1052.     \\<<REPLICATE(" ",44-LEN(ALLTRIM(STR(m.g_snippcnt,2))))>><<m.g_verti2>>
  1053.     \*       <<m.g_verti1>><<REPLICATE(" ",57)>><<m.g_verti2>>
  1054.     \*       <<m.g_corn3>><<REPLICATE(m.g_horiz,57)>><<m.g_corn4>>
  1055.     \*
  1056.     
  1057. *
  1058. * REMOVEMETA - Remove meta characters for documentation.
  1059. *
  1060. FUNCTION removemeta
  1061.     PRIVATE m.prompt, m.hotkey
  1062.     m.prompt = PROMPT
  1063.     m.hotkey = AT("\<",m.prompt)
  1064.     
  1065.     IF m.hotkey <> 0
  1066.         m.prompt = STUFF(m.prompt,m.hotkey,2,"")
  1067.     ENDIF
  1068.     
  1069.     m.disabl = AT("\",m.prompt)
  1070.     IF m.disabl <> 0
  1071.         m.prompt = STUFF(m.prompt,m.disabl,1,"")
  1072.     ENDIF
  1073.     RETURN m.prompt
  1074.     
  1075. *
  1076. * COMMENTBLOCK - Generate a comment block.
  1077. *
  1078. PROCEDURE commentblock
  1079.     PARAMETER m.snippet
  1080.     \
  1081.     \*       <<m.g_corn1>><<REPLICATE(m.g_horiz,57)>><<m.g_corn2>>
  1082.     \*       <<m.g_verti1>><<REPLICATE(" ",57)>><<m.g_verti2>>
  1083.     DO CASE
  1084.         CASE m.snippet == "setup"
  1085.             \*       <<m.g_verti1>>
  1086.             \\ <<PADC(" Setup Code",56," ")>>
  1087.         CASE m.snippet == "cleanup"
  1088.             \*       <<m.g_verti1>>
  1089.             \\ <<PADC(" Cleanup Code & Procedures",56," ")>>
  1090.         CASE m.snippet == "init"
  1091.             \*       <<m.g_verti1>>
  1092.             \\ <<PADC(" Initializing Code",56," ")>>
  1093.         CASE m.snippet == "menu"
  1094.             \*       <<m.g_verti1>>
  1095.             \\ <<PADC(" Menu Definition",56," ")>>
  1096.     ENDCASE
  1097.     \\<<m.g_verti2>>
  1098.     \*       <<m.g_verti1>><<REPLICATE(" ",57)>><<m.g_verti2>>
  1099.     \*       <<m.g_corn3>><<REPLICATE(m.g_horiz,57)>><<m.g_corn4>>
  1100.     \*
  1101.     \
  1102.     
  1103. **
  1104. ** Supporting routines
  1105. **
  1106.  
  1107. *
  1108. * ONSELECTION - Generate ON SELECTION... statements for menu items.
  1109. *
  1110. * Description:
  1111. * For pads and bars which have no submenu associated with them but
  1112. * instead have a non-empty Command field in the database, issue
  1113. * the ON SELECTION <command> statements.  If a snippet is associated
  1114. * with a pad then issue a call statement to the generated procedure
  1115. * containing the snippet.  Generated snippet procedure will be
  1116. * appended to the end of the output file.
  1117. *
  1118. PROCEDURE onselection
  1119.     PARAMETER m.which, m.name, m.ofname, m.commd
  1120.     PRIVATE m.trimname, m.basename
  1121.     IF EMPTY(PROCEDURE) AND EMPTY(COMMAND)
  1122.         RETURN
  1123.     ENDIF
  1124.     DO CASE
  1125.         CASE m.which == "pad"
  1126.             \ON SELECTION PAD <<m.name>>
  1127.         CASE m.which == "BAR"
  1128.             \ON SELECTION <<m.which+" "+m.name>>
  1129.     ENDCASE
  1130.     \\ OF <<m.ofname>>
  1131.     IF objcode = c_proc
  1132.         DO gensnippname
  1133.         m.trimname = SYS(2014,UPPER(m.g_outfile),UPPER(m.g_homedir))
  1134.         m.trimname = stripext(m.trimname)
  1135.         m.basename = basename(m.trimname)
  1136.         \\ ;
  1137.         \    DO <<g_snippets[g_nsnippets,1]>> ;
  1138.         \    IN LOCFILE("<<m.trimname>>"
  1139.         \\ ,"MPX;MPR|FXP;PRG"
  1140.         \\ ,"Where is <<m.basename>>?")
  1141.     ELSE
  1142.         m.commd = COMMAND
  1143.         \\ <<m.commd>>
  1144.     ENDIF
  1145.     
  1146. *
  1147. * GENSNIPPNAME - Generate a unique name for snippet procedure.
  1148. *
  1149. * Description:
  1150. * Lookup the #NAME name of this snippet, or alternatively 
  1151. * provide a unique name for a snippet of code associated with the
  1152. * generated menu.  Save this name in an array g_snippets.
  1153. *
  1154. PROCEDURE gensnippname
  1155.     g_nsnippets = g_nsnippets + 1
  1156.     g_snippets[g_nsnippets,1] = getcname(procedure)
  1157.     g_snippets[g_nsnippets,2] = RECNO()
  1158.     
  1159.     IF MOD(g_nsnippets,25) = 0
  1160.         DIMENSION g_snippets [g_nsnippets+25,2]
  1161.     ENDIF
  1162.     
  1163. *
  1164. * GENPROCCALL - Generate a call statement to snippet procedure.
  1165. *
  1166. * Description:
  1167. * Generate a call to the snippet procedure in the menu definition
  1168. * code.
  1169. *
  1170. PROCEDURE genproccall
  1171.     PRIVATE m.trimname, m.basename, m.proc
  1172.     IF singleline()
  1173.         m.proc = PROCEDURE
  1174.         \\ <<MLINE(m.proc,1)>>
  1175.     ELSE
  1176.         DO gensnippname
  1177.         m.trimname = SYS(2014,UPPER(m.g_outfile),UPPER(m.g_homedir))
  1178.         m.trimname = stripext(m.trimname)
  1179.         m.basename = basename(m.trimname)
  1180.         \\ ;
  1181.         \    DO <<g_snippets[m.g_nsnippets,1]>> ;
  1182.         \    IN LOCFILE("<<m.trimname>>"
  1183.         \\ ,"MPX;MPR|FXP;PRG"
  1184.         \\ ,"Where is <<m.basename>>?")
  1185.     ENDIF
  1186.     
  1187. *
  1188. * SINGLELINE - Determine if Memo contains only one line.
  1189. *
  1190. * Description:
  1191. * This procedure is used to decide if an ON SELECTION... statement
  1192. * and a snippet procedure will be needed (i.e., if more than one
  1193. * line of snippet code then its a snippet, otherwise its a command)
  1194. *
  1195. FUNCTION singleline
  1196.     PRIVATE m.size, m.i
  1197.     m.size = MEMLINES(PROCEDURE)
  1198.     IF m.size = 1
  1199.         RETURN .T.
  1200.     ENDIF
  1201.     m.i = m.size
  1202.     DO WHILE m.i > 1
  1203.         m.line = MLINE(PROCEDURE, m.i)
  1204.         IF NOT EMPTY(m.line)
  1205.             RETURN .F.
  1206.         ENDIF
  1207.         m.i = m.i - 1
  1208.     ENDDO
  1209.     
  1210. *
  1211. * GENPROCEDURES - Generate procedure/snippet code.
  1212. *
  1213. * Description:
  1214. * Generate 'PROCEDURE procedurename' statement and its body.
  1215. *
  1216. PROCEDURE genprocedures
  1217.     PRIVATE m.i
  1218.     IF m.g_graphic
  1219.         SET MESSAGE TO 'Generating procedures...'
  1220.     ENDIF
  1221.     FOR m.i = 1 TO m.g_nsnippets
  1222.         GOTO RECORD (g_snippets[m.i,2])
  1223.         DO genfuncheader WITH g_snippets[m.i,1]
  1224.         \PROCEDURE <<g_snippets[m.i,1]>>
  1225.         DO writecode WITH procedure
  1226.         \
  1227.     ENDFOR
  1228.     
  1229. *
  1230. * WRITECODE - Write contents of a memo to a low level file.
  1231. *
  1232. * Description:
  1233. * Receive a memo field as a parameter and write its contents out
  1234. * to the currently opened low level file whose handle is stored
  1235. * in the system memory variable _TEXT.  Contents of the system
  1236. * memory variable _pretext will affect the positioning of the
  1237. * generated text.
  1238. *
  1239. PROCEDURE writecode
  1240.     PARAMETER m.memo
  1241.     PRIVATE m.lines, m.i, m.thisline
  1242.     m.lines = MEMLINES(m.memo)
  1243.     _MLINE = 0
  1244.     FOR m.i = 1 TO m.lines
  1245.         m.thisline = MLINE(m.memo, 1, _MLINE)
  1246.         IF LEFT(UPPER(LTRIM(m.thisline)),5) == "#INSE"   && #INSERT
  1247.            DO GenInsertCode WITH m.thisline
  1248.         ELSE
  1249.            IF LEFT(UPPER(LTRIM(m.thisline)),5) <> "#NAME"
  1250.               \<<m.thisline>>
  1251.            ENDIF
  1252.         ENDIF
  1253.     ENDFOR
  1254.     
  1255. *
  1256. * GENSETUPCLEANUP - Generate setup/cleanup code.
  1257. *
  1258. PROCEDURE gensetupcleanup
  1259.     PARAMETER m.choice
  1260.     LOCATE FOR objtype = c_menu
  1261.     DO CASE
  1262.         CASE m.choice == "setup"
  1263.             IF EMPTY(setup)
  1264.                 RETURN
  1265.             ENDIF
  1266.             IF m.g_graphic
  1267.                 SET MESSAGE TO 'Generating Menu Setup Code...'
  1268.             ENDIF
  1269.             DO commentblock WITH m.choice
  1270.             DO writecode WITH setup
  1271.         CASE m.choice == "cleanup"
  1272.             IF EMPTY(cleanup)
  1273.                 RETURN
  1274.             ENDIF
  1275.             IF m.g_graphic
  1276.                 SET MESSAGE TO 'Generating Menu Cleanup Code...'
  1277.             ENDIF
  1278.             DO commentblock WITH m.choice
  1279.             DO writecode WITH cleanup
  1280.     ENDCASE
  1281.     
  1282. *
  1283. * STRIPEXT - Strip the extension from a file name.
  1284. *
  1285. * Description:
  1286. * Use the algorithm employed by FoxPRO itself to strip a
  1287. * file of an extension (if any): Find the rightmost dot in
  1288. * the filename.  If this dot occurs to the right of a "\"
  1289. * or ":", then treat everything from the dot rightward
  1290. * as an extension.  Of course, if we found no dot,
  1291. * we just hand back the filename unchanged.
  1292. *
  1293. * Parameters:
  1294. * filename - character string representing a file name
  1295. *
  1296. * Return value:
  1297. * The string "filename" with any extension removed
  1298. *
  1299. FUNCTION stripext
  1300.     PARAMETER m.filename
  1301.     PRIVATE m.dotpos, m.terminator
  1302.     m.dotpos = RAT(".", m.filename)
  1303.     m.terminator = MAX(RAT("\", m.filename), RAT(":", m.filename))
  1304.     IF m.dotpos > m.terminator
  1305.         m.filename = LEFT(m.filename, m.dotpos-1)
  1306.     ENDIF
  1307.     RETURN m.filename
  1308.     
  1309. *
  1310. * STRIPPATH - Strip the path from a file name.
  1311. *
  1312. * Description:
  1313. * Find positions of backslash in the name of the file.  If there is one
  1314. * take everything to the right of its position and make it the new file
  1315. * name.  If there is no slash look for colon.  Again if found, take
  1316. * everything to the right of it as the new name.  If neither slash
  1317. * nor colon are found then return the name unchanged.
  1318. *
  1319. * Parameters:
  1320. * filename - character string representing a file name
  1321. *
  1322. * Return value:
  1323. * The string "filename" with any path removed
  1324. *
  1325. FUNCTION strippath
  1326.     PARAMETER m.filename
  1327.     PRIVATE m.slashpos, m.namelen, m.colonpos
  1328.     m.slashpos = RAT("\", m.filename)
  1329.     IF m.slashpos > 0
  1330.         m.namelen  = LEN(m.filename) - m.slashpos
  1331.         m.filename = RIGHT(m.filename, m.namelen)
  1332.     ELSE
  1333.         m.colonpos = RAT(":", m.filename)
  1334.         IF m.colonpos > 0
  1335.             m.namelen  = LEN(m.filename) - m.colonpos
  1336.             m.filename = RIGHT(m.filename, m.namelen)
  1337.         ENDIF
  1338.     ENDIF
  1339.     RETURN m.filename
  1340.     
  1341. *
  1342. * BASENAME - returns strippath(stripext(filespec))
  1343. *
  1344. FUNCTION basename
  1345.     PARAMETER m.filespec
  1346.     RETURN strippath(stripext(m.filespec))
  1347.  
  1348. *
  1349. * GENINSERTCODE - Emit code from the #insert file, if any
  1350. * 
  1351. PROCEDURE GenInsertCode
  1352. PARAMETER strg
  1353. PRIVATE m.word1, m.filname, m.ins_fp, m.buffer
  1354.  
  1355. IF UPPER(LEFT(LTRIM(m.strg),5)) == "#INSE"
  1356.    m.word1 = wordnum(m.strg,1)
  1357.    m.filname = SUBSTR(m.strg,LEN(m.word1)+1)
  1358.    m.filname = ALLTRIM(CHRTRAN(m.filname,CHR(9),""))
  1359.    
  1360.    * Bail out if we can't find the file either explicitly or on the DOS path
  1361.    IF !FILE(m.filname)
  1362.       filname = FULLPATH(m.filname,1)
  1363.       IF !FILE(m.filname)
  1364.          \*Insert file <<m.filname>> could not be found
  1365.          RETURN
  1366.       ENDIF
  1367.    ENDIF
  1368.    
  1369.    ins_fp = FOPEN(m.filname)
  1370.    IF ins_fp > 0
  1371.       \* Inserted from <<strippath(m.filname)>>
  1372.       DO WHILE !feof(ins_fp)
  1373.          m.buffer = fgets(ins_fp)
  1374.          \<<m.buffer>>
  1375.       ENDDO
  1376.       =fclose(m.ins_fp)
  1377.       \* End of inserted lines
  1378.    ENDIF
  1379. ENDIF
  1380. *!*****************************************************************************
  1381. *!
  1382. *!       Function: JUSTPATH
  1383. *!
  1384. *!      Called by: FORCEEXT()         (function  in GENSCRN.PRG)
  1385. *!
  1386. *!*****************************************************************************
  1387. FUNCTION justpath
  1388. * Return just the path name from "filname"
  1389. PARAMETERS m.filname
  1390. PRIVATE ALL
  1391. m.filname = ALLTRIM(UPPER(m.filname))
  1392. IF '\' $ m.filname
  1393.    m.filname = SUBSTR(m.filname,1,RAT('\',m.filname))
  1394.    IF RIGHT(m.filname,1) = '\' AND LEN(m.filname) > 1 ;
  1395.             AND SUBSTR(m.filname,LEN(m.filname)-1,1) <> ':'
  1396.          filname = SUBSTR(m.filname,1,LEN(m.filname)-1)
  1397.    ENDIF
  1398.    RETURN m.filname
  1399. ELSE
  1400.    RETURN ''
  1401. ENDIF
  1402.     
  1403. **
  1404. ** Code Associated with the Thermometer
  1405. **
  1406.  
  1407. *
  1408. * ACTTHERM(<text>) - Activate thermometer.
  1409. *
  1410. * Description:
  1411. * Activates thermometer.  Update the thermometer with UPDTHERM().
  1412. * Thermometer window is named "thermometer."  Be sure to RELEASE
  1413. * this window when done with thermometer.  Creates the global
  1414. * m.g_thermwidth.
  1415. *
  1416. PROCEDURE acttherm
  1417.     PARAMETER m.text
  1418.     PRIVATE m.prompt
  1419.   
  1420.     IF m.g_graphic
  1421.         m.prompt = m.g_outfile
  1422.           m.prompt = thermfname(m.prompt)
  1423.         
  1424.         DO CASE
  1425.         CASE _WINDOWS
  1426.            DEFINE WINDOW thermomete ;
  1427.               AT  INT((SROW() - (( 5.615 * ;
  1428.               FONTMETRIC(1, m.g_dlgface, m.g_dlgsize, m.g_dlgstyle )) / ;
  1429.               FONTMETRIC(1, WFONT(1,""), WFONT( 2,""), WFONT(3,"")))) / 2), ;
  1430.               INT((SCOL() - (( 63.833 * ;
  1431.               FONTMETRIC(6, m.g_dlgface, m.g_dlgsize, m.g_dlgstyle )) / ;
  1432.               FONTMETRIC(6, WFONT(1,""), WFONT( 2,""), WFONT(3,"")))) / 2) ;
  1433.               SIZE 5.615,63.833 ;
  1434.               FONT m.g_dlgface, m.g_dlgsize ;
  1435.               STYLE m.g_dlgstyle ;
  1436.               NOFLOAT ;
  1437.               NOCLOSE ;
  1438.               NONE ;
  1439.               COLOR RGB(0, 0, 0, 192, 192, 192)
  1440.            MOVE WINDOW thermomete CENTER
  1441.            ACTIVATE WINDOW thermomete NOSHOW
  1442.            @ 0.5,3 SAY m.text FONT m.g_dlgface, m.g_dlgsize STYLE m.g_dlgstyle
  1443.            @ 1.5,3 SAY m.prompt FONT m.g_dlgface, m.g_dlgsize STYLE m.g_dlgstyle
  1444.            @ 0.000,0.000 TO 0.000,63.833 ;
  1445.               COLOR RGB(255, 255, 255, 255, 255, 255)
  1446.            @ 0.000,0.000 TO 5.615,0.000 ;
  1447.               COLOR RGB(255, 255, 255, 255, 255, 255)
  1448.            @ 0.385,0.667 TO 5.231,0.667 ;
  1449.               COLOR RGB(128, 128, 128, 128, 128, 128)
  1450.            @ 0.308,0.667 TO 0.308,63.167 ;
  1451.               COLOR RGB(128, 128, 128, 128, 128, 128)
  1452.            @ 0.385,63.000 TO 5.308,63.000 ;
  1453.               COLOR RGB(255, 255, 255, 255, 255, 255)
  1454.            @ 5.231,0.667 TO 5.231,63.167 ;
  1455.               COLOR RGB(255, 255, 255, 255, 255, 255)
  1456.            @ 5.538,0.000 TO 5.538,63.833 ;
  1457.               COLOR RGB(128, 128, 128, 128, 128, 128)
  1458.            @ 0.000,63.667 TO 5.615,63.667 ;
  1459.               COLOR RGB(128, 128, 128, 128, 128, 128)
  1460.            @ 3.000,3.333 TO 4.231,3.333 ;
  1461.               COLOR RGB(128, 128, 128, 128, 128, 128)
  1462.            @ 3.000,60.333 TO 4.308,60.333 ;
  1463.               COLOR RGB(255, 255, 255, 255, 255, 255)
  1464.            @ 3.000,3.333 TO 3.000,60.333 ;
  1465.               COLOR RGB(128, 128, 128, 128, 128, 128)
  1466.            @ 4.231,3.333 TO 4.231,60.333 ;
  1467.               COLOR RGB(255, 255, 255, 255, 255, 255)
  1468.            m.g_thermwidth = 56.269
  1469.         CASE _MAC
  1470.            DEFINE WINDOW thermomete ;
  1471.               AT  INT((SROW() - (( 5.62 * ;
  1472.               FONTMETRIC(1, m.g_dlgface, m.g_dlgsize, m.g_dlgstyle )) / ;
  1473.               FONTMETRIC(1, WFONT(1,""), WFONT( 2,""), WFONT(3,"")))) / 2), ;
  1474.               INT((SCOL() - (( 63.83 * ;
  1475.               FONTMETRIC(6, m.g_dlgface, m.g_dlgsize, m.g_dlgstyle )) / ;
  1476.               FONTMETRIC(6, WFONT(1,""), WFONT( 2,""), WFONT(3,"")))) / 2) ;
  1477.               SIZE 5.62,63.83 ;
  1478.               FONT m.g_dlgface, m.g_dlgsize ;
  1479.               STYLE m.g_dlgstyle ;
  1480.               NOFLOAT ;
  1481.               NOCLOSE ;
  1482.                   NONE ;
  1483.               COLOR RGB(0, 0, 0, 192, 192, 192)
  1484.            MOVE WINDOW thermomete CENTER
  1485.            ACTIVATE WINDOW thermomete NOSHOW
  1486.            @ 0.000,0.000 TO 5.62,63.83 PATTERN 1;
  1487.               COLOR RGB(192, 192, 192, 192, 192, 192)
  1488.               IF ISCOLOR()
  1489.               @ 0.000,0.000 TO 5.62,63.83 PATTERN 1;
  1490.                  COLOR RGB(192, 192, 192, 192, 192, 192)
  1491.               @ 0.000,0.000 TO 0.000,63.83 ;
  1492.                  COLOR RGB(255, 255, 255, 255, 255, 255)
  1493.               @ 0.000,0.000 TO 5.62,0.000 ;
  1494.                  COLOR RGB(255, 255, 255, 255, 255, 255)
  1495.               @ 0.385,0.67 TO 5.23,0.67 ;
  1496.                  COLOR RGB(128, 128, 128, 128, 128, 128)
  1497.               @ 0.31,0.67 TO 0.31,63.17 ;
  1498.                  COLOR RGB(128, 128, 128, 128, 128, 128)
  1499.               @ 0.385,63.000 TO 5.31,63.000 ;
  1500.                  COLOR RGB(255, 255, 255, 255, 255, 255)
  1501.               @ 5.23,0.67 TO 5.23,63.17 ;
  1502.                  COLOR RGB(255, 255, 255, 255, 255, 255)
  1503.               @ 5.54,0.000 TO 5.54,63.83 ;
  1504.                  COLOR RGB(128, 128, 128, 128, 128, 128)
  1505.               @ 0.000,63.67 TO 5.62,63.67 ;
  1506.                  COLOR RGB(128, 128, 128, 128, 128, 128)
  1507.               @ 3.000,3.33 TO 4.23,3.33 ;
  1508.                  COLOR RGB(128, 128, 128, 128, 128, 128)
  1509.               @ 3.000,60.33 TO 4.31,60.33 ;
  1510.                  COLOR RGB(255, 255, 255, 255, 255, 255)
  1511.               @ 3.000,3.33 TO 3.000,60.33 ;
  1512.                  COLOR RGB(128, 128, 128, 128, 128, 128)
  1513.               @ 4.23,3.33 TO 4.23,60.33 ;
  1514.                  COLOR RGB(255, 255, 255, 255, 255, 255)
  1515.               ELSE
  1516.               @ 0.000, 0.000 TO 5.62, 63.830  PEN 2
  1517.                @ 0.230, 0.500 TO 5.39, 63.333  PEN 1
  1518.               ENDIF
  1519.            @ 0.5,3 SAY m.text FONT m.g_dlgface, m.g_dlgsize STYLE m.g_dlgstyle+"T" ;
  1520.               COLOR RGB(0,0,0,192,192,192)
  1521.            @ 1.5,3 SAY m.prompt FONT m.g_dlgface, m.g_dlgsize STYLE m.g_dlgstyle+"T" ;
  1522.               COLOR RGB(0,0,0,192,192,192)
  1523.  
  1524.                 m.g_thermwidth = 56.27
  1525.                 IF !ISCOLOR()
  1526.                    @ 3.000,3.33 TO 4.23, (m.g_thermwidth + 1) + 3.33 
  1527.                 ENDIF
  1528.         ENDCASE
  1529.         SHOW WINDOW thermomete TOP
  1530.     ELSE
  1531.         m.prompt = SUBSTR(SYS(2014,UPPER(m.g_outfile)),1,48)+;
  1532.             IIF(LEN(m.g_outfile)>48,"...","")
  1533.         
  1534.         DEFINE WINDOW thermomete;
  1535.             FROM INT((SROW()-6)/2), INT((SCOL()-57)/2) ;
  1536.             TO INT((SROW()-6)/2) + 6, INT((SCOL()-57)/2) + 57;
  1537.             DOUBLE COLOR SCHEME 5
  1538.         
  1539.         ACTIVATE WINDOW thermomete NOSHOW
  1540.         
  1541.         m.g_thermwidth = 50
  1542.         @ 0,3 SAY m.text
  1543.         @ 1,3 SAY UPPER(m.prompt)
  1544.         @ 2,1 TO 4,m.g_thermwidth+4 &g_boxstrg
  1545.         
  1546.         SHOW WINDOW thermomete TOP
  1547.     ENDIF
  1548.     
  1549. *
  1550. * UPDTHERM(<percent>) - Update thermometer.
  1551. *
  1552. PROCEDURE updtherm
  1553. PARAMETER m.percent
  1554. PRIVATE m.nblocks, m.percent
  1555. ACTIVATE WINDOW thermomete
  1556. m.nblocks = (m.percent/100) * (m.g_thermwidth)
  1557. DO CASE
  1558. CASE _WINDOWS
  1559.    @ 3.000,3.333 TO 4.231,m.nblocks + 3.333 ;
  1560.       PATTERN 1 COLOR RGB(128, 128, 128, 128, 128, 128)
  1561. CASE _MAC
  1562.    @ 3.000,3.33 TO 4.23,m.nblocks + 3.33 ;
  1563.       PATTERN 1 COLOR RGB(0, 0, 128, 0, 0, 128)
  1564. OTHERWISE
  1565.    @ 3,3 SAY REPLICATE("€",m.nblocks)
  1566. ENDCASE
  1567.     
  1568. *
  1569. * DEACTTHERMO - Deactivate and Release thermometer window.
  1570. *
  1571. PROCEDURE deactthermo
  1572.     RELEASE WINDOW thermomete
  1573.     
  1574.  
  1575. *!*****************************************************************************
  1576. *!
  1577. *!      Procedure: THERMFNAME
  1578. *!
  1579. *!*****************************************************************************
  1580. FUNCTION thermfname
  1581. PARAMETER m.fname
  1582. PRIVATE m.addelipse, m.g_pathsep, m.g_thermfface, m.g_thermfsize, m.g_thermfstyle
  1583.  
  1584. #define c_space 40
  1585. IF _MAC
  1586.     m.g_thermfface = "Geneva"
  1587.     m.g_thermfsize = 10
  1588.     m.g_thermfstyle = "B"
  1589. ELSE
  1590.     m.g_thermfface = "MS Sans Serif"
  1591.     m.g_thermfsize = 8
  1592.     m.g_thermfstyle = "B"
  1593. ENDIF
  1594.  
  1595. * Translate the filename into Mac native format
  1596. IF _MAC
  1597.     m.g_pathsep = ":"
  1598.     m.fname = LOWER(SYS(2027, m.fname))
  1599. ELSE
  1600.     m.g_pathsep = "\"    
  1601. ENDIF
  1602.  
  1603. IF TXTWIDTH(m.fname,m.g_thermfface,m.g_thermfsize,m.g_thermfstyle) > c_space
  1604.     * Make it fit in c_space
  1605.     m.fname = partialfname(m.fname, c_space - 1)
  1606.     m.addelipse = .F.
  1607.     DO WHILE TXTWIDTH(m.fname+'...',m.g_thermfface,m.g_thermfsize,m.g_thermfstyle) > c_space
  1608.         m.fname = LEFT(m.fname, LEN(m.fname) - 1)
  1609.         m.addelipse = .T.
  1610.     ENDDO
  1611.     IF m.addelipse
  1612.         m.fname = m.fname + "..."
  1613.    ENDIF
  1614. ENDIF
  1615. RETURN m.fname
  1616.  
  1617.  
  1618.  
  1619. *!*****************************************************************************
  1620. *!
  1621. *!      Procedure: PARTIALFNAME
  1622. *!
  1623. *!*****************************************************************************
  1624. FUNCTION partialfname    
  1625. PARAMETER m.filname, m.fillen
  1626. * Return a filname no longer than m.fillen characters.  Take some chars
  1627. * out of the middle if necessary.  No matter what m.fillen is, this function
  1628. * always returns at least the file stem and extension.
  1629. PRIVATE m.bname, m.elipse, m.remain
  1630. m.elipse = "..." + m.g_pathsep
  1631. IF _MAC
  1632.     m.bname = SUBSTR(m.filname, RAT(":",m.filname)+1)
  1633. ELSE
  1634.     m.bname = justfname(m.filname)
  1635. ENDIF
  1636. DO CASE
  1637. CASE LEN(m.filname) <= m.fillen 
  1638.    m.retstr = m.filname
  1639. CASE LEN(m.bname) + LEN(m.elipse) >= m.fillen
  1640.    m.retstr = m.bname
  1641. OTHERWISE
  1642.    m.remain = MAX(m.fillen - LEN(m.bname) - LEN(m.elipse), 0)
  1643.    IF _MAC
  1644.        m.retstr = LEFT(SUBSTR(m.filname,1,RAT(":",m.filname)-1),m.remain) ;
  1645.             +m.elipse+m.bname
  1646.    ELSE
  1647.          m.retstr = LEFT(justpath(m.filname),m.remain)+m.elipse+m.bname
  1648.    ENDIF
  1649. ENDCASE
  1650. RETURN m.retstr
  1651.  
  1652. **
  1653. ** Error Handling Code
  1654. **
  1655.  
  1656. *
  1657. * ERRORHANDLER - Error Processing Center.
  1658. *
  1659. PROCEDURE errorhandler
  1660.     PARAMETERS m.messg, m.lineno, m.code
  1661.     IF ERROR() = 22
  1662.         ON ERROR &onerror
  1663.         DO cleanup
  1664.         CANCEL
  1665.     ENDIF
  1666.     
  1667.     DO CASE
  1668.         CASE m.code == "Minor"
  1669.             DO errlog WITH m.messg, m.lineno
  1670.             m.g_status = 1
  1671.         CASE m.code == "Serious"
  1672.             DO errlog  WITH m.messg, m.lineno
  1673.             DO errshow WITH m.messg, m.lineno
  1674.             m.g_error = .T.
  1675.             m.g_status = 2
  1676.             ON ERROR
  1677.         CASE m.code == "Fatal"
  1678.             IF NOT m.g_nohandle
  1679.                 DO errlog  WITH m.messg, m.lineno
  1680.             ENDIF
  1681.             DO errshow WITH m.messg, m.lineno
  1682.             IF WEXIST("Thermomete") AND WVISIBLE("Thermomete")
  1683.                 RELEASE WINDOW thermometer
  1684.             ENDIF
  1685.             ON ERROR
  1686.             DO cleanup
  1687.             CANCEL
  1688.     ENDCASE
  1689.     
  1690. *
  1691. * ESCHANDLER - Escape handler.
  1692. *
  1693. PROCEDURE eschandler
  1694.     ON ERROR
  1695.     WAIT WINDOW "Generation process stopped." NOWAIT
  1696.     DO builddisable
  1697.     IF m.g_status > 0
  1698.         ERASE (m.g_outfile)
  1699.     ENDIF
  1700.     IF WEXIST("Thermomete") AND WVISIBLE("Thermomete")
  1701.         RELEASE WINDOW thermometer
  1702.     ENDIF
  1703.     DO cleanup
  1704.     CANCEL
  1705.     
  1706. *
  1707. * ERRLOG - Insert error message into the error log.
  1708. *
  1709. PROCEDURE errlog
  1710.     PARAMETER m.messg, m.lineno
  1711.     PRIVATE m.savehandle
  1712.     m.savehandle = _TEXT
  1713.     DO openerrfile
  1714.     SET CONSOLE OFF
  1715.     
  1716.     \\GENERATOR: <<ALLTRIM(m.messg)>>
  1717.     IF NOT EMPTY(m.lineno)
  1718.         \\ LINE NUMBER: <<m.lineno>>
  1719.     ENDIF
  1720.     \
  1721.     = FCLOSE(_TEXT)
  1722.     _TEXT = m.savehandle
  1723.     
  1724. *
  1725. * ERRSHOW - Display error message in the alert box.
  1726. *
  1727. PROCEDURE errshow
  1728.     PARAMETER m.msg, m.lineno
  1729.     PRIVATE m.curcursor
  1730.     
  1731.     IF m.g_graphic
  1732.         DEFINE WINDOW alert ;
  1733.             AT  INT((SROW() - (( 5.615 * ;
  1734.             fontmetric(1, m.g_dlgface, m.g_dlgsize, m.g_dlgstyle )) / ;
  1735.             fontmetric(1, wfont(1,""), wfont(2,""), wfont(3,"")))) / 2), ;
  1736.             INT((SCOL() - (( 63.833 * ;
  1737.             fontmetric(6, m.g_dlgface, m.g_dlgsize, m.g_dlgstyle )) / ;
  1738.             fontmetric(6, wfont(1,""), wfont(2,""), wfont(3,"")))) / 2) ;
  1739.             SIZE 5.615,63.833 ;
  1740.             font m.g_dlgface, m.g_dlgsize ;
  1741.             STYLE m.g_dlgstyle ;
  1742.             NOCLOSE ;
  1743.             DOUBLE ;
  1744.             TITLE "Genmenu Error" ;
  1745.             COLOR rgb(0, 0, 0, 255, 255, 255)
  1746.         
  1747.         ACTIVATE WINDOW alert NOSHOW
  1748.         
  1749.         m.msg = SUBSTR(m.msg,1,44)+IIF(LEN(m.msg)>44,"...","")
  1750.         @ 1,(WCOLS()-txtwidth( m.msg ))/2 SAY m.msg
  1751.         
  1752.         m.msg = "Line Number: "+STR(m.lineno, 4)
  1753.         @ 2,(WCOLS()-txtwidth( m.msg ))/2 SAY m.msg
  1754.         
  1755.         m.msg = "Press any key to cleanup and exit..."
  1756.         @ 3,(WCOLS()-txtwidth( m.msg ))/2 SAY m.msg
  1757.         
  1758.         SHOW WINDOW alert
  1759.     ELSE
  1760.         DEFINE WINDOW alert;
  1761.             FROM INT((SROW()-6)/2), INT((SCOL()-50)/2) TO INT((SROW()-6)/2) + 6, INT((SCOL()-50)/2) + 50 ;
  1762.             FLOAT NOGROW NOCLOSE NOZOOM    SHADOW DOUBLE;
  1763.             COLOR SCHEME 7
  1764.         
  1765.         ACTIVATE WINDOW alert
  1766.         
  1767.         @ 0,0 CLEAR
  1768.         @ 1,0 SAY PADC(SUBSTR(m.msg,1,44)+;
  1769.             IIF(LEN(m.msg)>44,"...",""), WCOLS())
  1770.         @ 2,0 SAY PADC("Line Number: "+STR(m.lineno, 4), WCOLS())
  1771.         @ 3,0 SAY PADC("Press any key to cleanup and exit...", WCOLS())
  1772.     ENDIF
  1773.     
  1774.     m.curcursor = SET( "CURSOR" )
  1775.     SET CURSOR OFF
  1776.     
  1777.     WAIT ""
  1778.     
  1779.     RELEASE WINDOW alert
  1780.     SET CURSOR &curcursor
  1781.     
  1782.     RELEASE WINDOW alert
  1783.     
  1784. *
  1785. * OPENERRFILE - Open error file.
  1786. *
  1787. PROCEDURE openerrfile
  1788.     PRIVATE m.errfile, m.errhandle
  1789.     m.errfile   = m.g_errlog+".ERR"
  1790.     m.errhandle = FOPEN(m.errfile,2)
  1791.     IF m.errhandle < 0
  1792.         m.errhandle = FCREATE(m.errfile)
  1793.         IF m.errhandle < 0
  1794.             DO errshow WITH ".ERR could not be opened...", LINENO()
  1795.             m.g_status = 2
  1796.             IF WEXIST("Thermomete") AND WVISIBLE("Thermomete")
  1797.                 RELEASE WINDOW thermometer
  1798.             ENDIF
  1799.             ON ERROR
  1800.             RETURN TO MASTER
  1801.         ENDIF
  1802.     ELSE
  1803.         = FSEEK(m.errhandle,0,2)
  1804.     ENDIF
  1805.     IF SET("TEXTMERGE") = "OFF"
  1806.         SET TEXTMERGE ON
  1807.     ENDIF
  1808.     _TEXT = m.errhandle
  1809.  
  1810. *
  1811. * GETCNAME - Manufacture a procedure name, unless there is a #NAME directive
  1812. *
  1813. FUNCTION getcname
  1814. PARAMETERS snippet
  1815. PRIVATE ALL
  1816. IF proctype = 1
  1817.    numlines = MEMLINES(snippet)
  1818.    IF m.numlines > 0
  1819.       _MLINE = 0
  1820.       m.i = 1
  1821.       DO WHILE m.i <= m.numlines
  1822.          m.thisline = UPPER(ALLTRIM(MLINE(snippet,1, _MLINE)))
  1823.          DO CASE
  1824.          CASE LEFT(m.thisline,5) == "#NAME"
  1825.             RETURN ALLTRIM(SUBSTR(m.thisline,6))
  1826.          CASE EMPTY(m.thisline) OR iscomment(m.thisline)
  1827.             * Do nothing.  Get next line.
  1828.          OTHERWISE
  1829.             EXIT 
  1830.          ENDCASE
  1831.          m.i = m.i + 1
  1832.       ENDDO
  1833.    ENDIF
  1834. ENDIF
  1835. RETURN LOWER(SYS(2015))
  1836.  
  1837. *
  1838. * ISCOMMENT - Determine if textline is a comment line.
  1839. *
  1840. FUNCTION IsComment
  1841. PARAMETER m.textline
  1842. PRIVATE m.asterisk, m.isnote, m.ampersand, m.statement
  1843. IF EMPTY(m.textline)
  1844.    RETURN .F.
  1845. ENDIF
  1846. m.statement = UPPER(ALLTRIM(m.textline))
  1847.  
  1848. m.asterisk  = AT("*", LEFT(m.statement,1))
  1849. m.ampersand = AT(CHR(38)+CHR(38), LEFT(m.statement,2))
  1850. m.isnote    = AT("NOTE", LEFT(m.statement,4))
  1851.  
  1852. DO CASE
  1853. CASE (m.asterisk = 1 OR m.ampersand = 1)
  1854.    RETURN .T.
  1855. CASE (m.isnote = 1 ;
  1856.         AND (LEN(m.statement) <= 4 OR SUBSTR(m.statement,5,1) = ' '))
  1857.    * Don't be fooled by something like "notebook = 7"
  1858.    RETURN .T.
  1859. ENDCASE
  1860. RETURN .F.
  1861. *
  1862. * WORDNUM - Returns w_num-th word from string strg
  1863. *
  1864. FUNCTION wordnum
  1865. PARAMETERS strg,w_num
  1866. PRIVATE strg,s1,w_num,ret_str
  1867.  
  1868. m.s1 = ALLTRIM(m.strg)
  1869.  
  1870. * Replace tabs with spaces
  1871. m.s1 = CHRTRAN(m.s1,CHR(9)," ")
  1872.  
  1873. * Reduce multiple spaces to a single space
  1874. DO WHILE AT('  ',m.s1) > 0
  1875.    m.s1 = STRTRAN(m.s1,'  ',' ')
  1876. ENDDO
  1877.  
  1878. ret_str = ""
  1879. DO CASE
  1880. CASE m.w_num > 1
  1881.    DO CASE
  1882.    CASE AT(" ",m.s1,m.w_num-1) = 0   && No word w_num.  Past end of string.
  1883.       m.ret_str = ""
  1884.    CASE AT(" ",m.s1,m.w_num) = 0     && Word w_num is last word in string.
  1885.       m.ret_str = SUBSTR(m.s1,AT(" ",m.s1,m.w_num-1)+1,255)
  1886.    OTHERWISE                         && Word w_num is in the middle.
  1887.       m.strt_pos = AT(" ",m.s1,m.w_num-1)
  1888.       m.ret_str  = SUBSTR(m.s1,strt_pos,AT(" ",m.s1,m.w_num)+1 - strt_pos)
  1889.    ENDCASE
  1890. CASE m.w_num = 1
  1891.    IF AT(" ",m.s1) > 0               && Get first word.
  1892.       m.ret_str = SUBSTR(m.s1,1,AT(" ",m.s1)-1)
  1893.    ELSE                              && There is only one word.  Get it.
  1894.       m.ret_str = m.s1
  1895.    ENDIF
  1896. ENDCASE
  1897. RETURN ALLTRIM(m.ret_str)
  1898. *!*****************************************************************************
  1899. *!
  1900. *!      Function: VERSNUM
  1901. *!
  1902. *!*****************************************************************************
  1903. FUNCTION versnum
  1904. * Return string corresponding to FoxPro version number
  1905. RETURN wordnum(vers(),2)
  1906.  
  1907. *!*****************************************************************************
  1908. *!
  1909. *!       Function: JUSTFNAME
  1910. *!
  1911. *!      Called by: FORCEEXT()         (function  in GENSCRN.PRG)
  1912. *!
  1913. *!*****************************************************************************
  1914. FUNCTION justfname
  1915. PARAMETERS m.filname
  1916. PRIVATE ALL
  1917. IF RAT('\',m.filname) > 0
  1918.    m.filname = SUBSTR(m.filname,RAT('\',m.filname)+1,255)
  1919. ENDIF
  1920. IF AT(':',m.filname) > 0
  1921.    m.filname = SUBSTR(m.filname,AT(':',m.filname)+1,255)
  1922. ENDIF
  1923. RETURN ALLTRIM(UPPER(m.filname))
  1924.  
  1925. )
  1926. *!
  1927. *!lnamem.s1,e   m.ret_str  =W alert
  1928.     SET       m.ret_str = SET  
  1929.     RELEA E W    F'F   t
  1930.      
  1931. *l* O EA F   LE - Opos = AT(" ",m LE - Opos = AT("'F ,m LE - Opos = ATte    = )
  1932. S snippet
  1933. PRIVATlname,AT(':'m LE - OposWei2     
  1934. *l* 55) SUBSTR(m.s1,strt"t la  PF T.':' 0     && Word w_ AS******me)           E - Opos = ATte                E - Opon = ATte          n     E - Opon = Anon non non non nonFE =   to